home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 52 / Amiga Format AFCD52 (Issue 136, May 2000).iso / -screenplay- / shareware / solitarexx / scripts / freecell.srx < prev    next >
Text File  |  2000-02-29  |  2KB  |  113 lines
  1. /*********************************\
  2. ** Free Cell v1.0 for Solitarexx **
  3. **     by Michal Szafranski      **
  4. \*********************************/
  5. OPTIONS RESULTS
  6.  
  7. tex = '"Free Cell"'
  8. wintex = '"We Have a Winner"'
  9. ADDBUTTON 0 10 "Start"
  10. ADDTEXT 4 42 tex 6
  11. ADDBUTTON 12 10 "Abort"
  12. ADDTEXT 14 42 tex 6
  13. SELECTGUI 1
  14.  
  15. SCREENSIZE 2 15 8 0
  16. DO i = 0 TO 7
  17.     NEWSTACK 3 8 0 i 1 0 0 15
  18.     stack.i = RESULT
  19. END
  20. DO i = 0 TO 3
  21.     NEWSTACK 2 8 i+2 i 0 0 0
  22.     base.i = RESULT
  23. END
  24. DO i = 0 TO 3
  25.     NEWSTACK 1 8 (i=0) i+4 0 0 0
  26.     help.i = RESULT
  27. END
  28. deck = help.0
  29. ADDCARDS deck SHUFFLED
  30.  
  31. DO FOREVER
  32.     ACTION
  33.     PARSE VAR RESULT act rest
  34.     IF act = 1 THEN EXIT
  35.     IF act = 3 THEN CALL GAME
  36. END
  37.  
  38. GAME:
  39.     CLEANUP deck
  40.     SETGADGET 14 STR tex
  41.     SELECTGUI 4
  42.     sel = 0
  43.     fin = 0
  44.     DO i=0 TO 7
  45.         CARDSELECT deck 7-(i>3)
  46.         MOVECARDS deck stack.i REVERSE
  47.     END
  48.     DO FOREVER
  49.         ACTION
  50.         PARSE VAR RESULT act stack sid card
  51.         SELECT
  52.         WHEN act = 1 THEN EXIT
  53.         WHEN act = 2 & sel = 0 & card>0 THEN sel = stack
  54.         WHEN act = 2 & sel > 0 THEN DO
  55.             SELECT
  56.                 WHEN sid = 2 | sel = stack THEN CALL DOBASE
  57.                 WHEN sid = 1 THEN CALL DOHELP
  58.                 WHEN sid = 3 THEN CALL DOSTACKS
  59.                 OTHERWISE ERRBEEP
  60.             END
  61.             sel = 0
  62.         END
  63.         WHEN act = 3 THEN DO
  64.             SELECTGUI 1
  65.             RETURN
  66.         END
  67.         OTHERWISE ERRBEEP
  68.         END
  69.     END
  70. RETURN
  71. DOHELP:
  72.     CARDSELECT stack 1
  73.     IF RESULT = '' THEN MOVECARDS sel stack
  74.     ELSE ERRBEEP
  75. RETURN
  76. DOSTACKS:
  77.     CARDSELECT sel 0 RELATIVE
  78.     PARSE VAR RESULT kolors wars xx
  79.     CARDSELECT stack 1
  80.     PARSE VAR RESULT kolor war xx
  81.     IF kolor = '' THEN DO
  82.         war = wars+1
  83.         kolor = kolors + 1
  84.     END
  85.     IF war = wars+1 & ((kolor+kolors) // 2) THEN MOVECARDS sel stack ATONCE
  86.     ELSE ERRBEEP
  87. RETURN
  88. DOBASE:
  89.     IF sel~=stack THEN CALL CHBASE
  90.     ELSE DO i= 0 TO 3 UNTIL ok=0
  91.         stack = base.i
  92.         CALL CHBASE
  93.     END
  94.     IF ok=0 THEN DO
  95.         fin = fin +1
  96.         MOVECARDS sel stack
  97.         IF fin = 52 THEN SETGADGET 14 STR wintex
  98.     END
  99.     ELSE ERRBEEP
  100. RETURN
  101. CHBASE:
  102.     CARDSELECT sel 1
  103.     PARSE VAR RESULT kolors wars xx
  104.     CARDSELECT stack 1
  105.     PARSE VAR RESULT kolor war xx
  106.     IF kolor = '' THEN DO
  107.         kolor = kolors
  108.         war = -1
  109.     END
  110.     IF kolor = kolors & (wars - war) = 1 THEN ok = 0
  111.     ELSE ok = 1
  112. RETURN
  113.